home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / dbase / lib19.zip / PROC.PRG < prev    next >
Text File  |  1992-09-28  |  76KB  |  1,913 lines
  1. *-- PROGRAM.....: PROC.PRG 
  2. *-------------------------------------------------------------------------------
  3. *-- Programmer..: Kenneth J. Mayer, (KENMAYER on BORBBS)
  4. *-- Date........: 09/28/1992
  5. *-- Version.....: 2.9  -- See WHATS.NEW and README.TXT files (both ASCII),
  6. *--               both files uploaded to BORBBS with this file in one
  7. *--               zipped file.
  8. *-- Notes.......: This procedure file is part of the new and improved set of
  9. *--               files, re-designed for dBASE IV, 1.5. The complete set is
  10. *--               contained in the file: LIB19.ZIP. Please read README.TXT
  11. *--               for all instructions.
  12. *===============================================================================
  13.  
  14. *===============================================================================
  15. * MESSAGE/SCREEN PROCESSING ROUTINES -- includes message boxes, shadowing,
  16. * and centering of text ... Anything not here is in the library file: 
  17. * SCREEN.PRG.
  18. *===============================================================================
  19.  
  20. PROCEDURE PrintErr
  21. *-------------------------------------------------------------------------------
  22. *-- Programmer..: Ken Mayer (KENMAYER)
  23. *-- Date........: 05/24/1991
  24. *-- Notes.......: Used to display a printer error for STAND-ALONE
  25. *--               systems. (The dBASE function PRINTSTATUS() doesn't work
  26. *--               well on a Network with Print Spoolers ...)
  27. *-- Written for.: dBASE IV, 1.1
  28. *-- Rev. History: None
  29. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  30. *--               CENTER               Procedure in PROC.PRG
  31. *-- Called by...: Any
  32. *-- Usage.......: do printerr
  33. *-- Example.....: do setprint  && if it hasn't been done
  34. *--               if .not. printstatus()
  35. *--                  DO PRINTERR
  36. *--               endif
  37. *--               *    or
  38. *--               do while .not. printstatus() && my preference ... loop!
  39. *--                  DO PRINTERR
  40. *--               enddo
  41. *-- Returns.....: None
  42. *-- Parameters..: None
  43. *-------------------------------------------------------------------------------
  44.  
  45.     private cColor, cDummy, cCursor
  46.     
  47.     if iscolor()    && if we're using a color monitor, use yellow on red
  48.         cColor = "RG+/R,RG+/R,RG+/R"
  49.     else            && otherwise, use black on white
  50.         cColor = "N/W,N/W,N/W"
  51.     endif
  52.     
  53.     activate screen
  54.     define window wPErr from  7,15 to 16,57 double color &cColor
  55.     save screen to sPErr       && store current screen
  56.     do shadow with 7,15,16,57    && shadow box!
  57.     activate window wPErr      && here we go ..
  58.     
  59.     cCursor=set("CURSOR")      && save cursor setting
  60.     set cursor off             && turn cursor off
  61.                                && display message
  62.     do center with 0,40,"",chr(7) + "*** PRINTER ERROR ***"
  63.     do center with 2,40,""," The printer is not ready. Please check:"
  64.     do center with 3,40,"","1) that the printer is ON,        "
  65.     do center with 4,40,"","2) that the printer is ONLINE, and"
  66.     do center with 5,40,"","3) that the printer has paper.    "
  67.     do center with 7,40,"","Press any key to continue . . ."
  68.     
  69.     cDummy=inkey(0)            && wait for user to press a key ...
  70.     set cursor &cCursor        && set cursor to original setting ...
  71.     
  72.     deactivate window wPErr    && cleanup
  73.     release window wPErr
  74.     restore screen from sPErr
  75.     release screen sPErr
  76.     
  77. RETURN  
  78. *-- EoP: PrintErr
  79.  
  80. PROCEDURE Open_Screen
  81. *-------------------------------------------------------------------------------
  82. *-- Programmer..: Rick Price (HAMMETT)
  83. *-- Date........: 05/24/1991
  84. *-- Notes.......: Used to give a texture to the background of the screen
  85. *--               I got this from Rick when he uploaded it as part of his 
  86. *--               original entry to a Color Contest on the ATBBS. It is
  87. *--               kinda nice to have that texture on the screen, keeps it
  88. *--               from being monotonous.
  89. *-- Written for.: dBASE IV, 1.1
  90. *-- Rev. History: None
  91. *-- Calls.......: None
  92. *-- Called by...: Any
  93. *-- Usage.......: do open_screen
  94. *-- Example.....: do open_screen
  95. *-- Returns.....: None
  96. *-- Parameters..: None
  97. *-------------------------------------------------------------------------------
  98.  
  99.     private nRow, cBackDrp, nHoldRow
  100.     
  101.     clear
  102.     nRow=0
  103.     cBackdrp = chr(176)  && chr(176) = "░", chr(177) = "▒", chr(178) = "▓"
  104.     do while nRow < 3
  105.        @nRow,0 to nRow+3,79 cBackdrp  && fill this section of the screen
  106.        nHoldRow = nRow
  107.        nRow = nRow + 6
  108.        @nRow,0 to nRow+3,79 cBackdrp
  109.        nRow = nRow + 6
  110.        @nRow,0 to nRow+3,79 cBackdrp
  111.        nRow = nRow + 6
  112.        @nRow,0 to nRow+3,79 cBackdrp
  113.        nRow = nHoldRow + 1
  114.     enddo
  115.     @24,0 to 24,79 cBackdrp
  116.  
  117. RETURN
  118. *-- EoP: OpenScreen
  119.  
  120. PROCEDURE JazClear
  121. *-------------------------------------------------------------------------------
  122. *-- Programmer..: Rick Price (HAMMETT)
  123. *-- Date........: 05/24/1991
  124. *-- Notes.......: Used to clear the screen from the middle out --
  125. *--               could be used with OpenScreen, above. I got this
  126. *--               from Rick at the same time I got the other routine above ...
  127. *--               This requires a full screen (0,0 to 23,79 ...)
  128. *-- Written for.: dBASE IV, 1.1
  129. *-- Rev. History: None
  130. *-- Calls.......: None
  131. *-- Called by...: Any
  132. *-- Usage.......: do jazclear
  133. *-- Examples....: do jazclear
  134. *-- Returns.....: None
  135. *-- Parameters..: None
  136. *-------------------------------------------------------------------------------
  137.  
  138.     private nWinR1, nWinR2, nWinC1, nWinC2, nStep, mnWinC1, mnWinC2, ;
  139.             mnWinR1, mnWinR2, nStep, nTmpAdjR, nTmpAdjC, nAdjRow, nAdjCol
  140.     private nColLeft, nColRite, nRowTop, nRowBot
  141.     
  142.     nWinR1 = 0     && row 1
  143.     nWinR2 = 24  && row 2
  144.     nWinC1 = 0   && column 1
  145.     nWinC2 = 79  && column 2
  146.     nStep = 1    && amount to increment by
  147.       * set starting point
  148.     mnWinC1 = int((nWinC2-nWinC1)/2)+nWinC1
  149.     mnWinC2 = mnWinC1+1
  150.     mnWinR1 = int((nWinR2-nWinR1)/2)+nWinR1
  151.     mnWinR2 = mnWinR1+1
  152.     
  153.     ** Adjust step offset values: nColOff & nRowOff
  154.     ** Vertical steps: nWinR1-nWinR1
  155.     nTmpAdjR = int((nWinR2 - nWinR1)/2)
  156.     nTmpAdjC = int((nWinC2 - nWinC1)/2)
  157.     
  158.     nAdjRow = ;
  159.     iif(nTmpAdjC > nTmpAdjR, nTmpAdjR/nTmpAdjC,1) * nStep
  160.     
  161.     nAdjCol = ;
  162.     iif(nTmpAdjR > nTmpAdjC, nTmpAdjC/nTmpAdjR,1) * nStep
  163.     
  164.     ncolleft = nWinC1
  165.     ncolrite = nWinC2
  166.     nRowTop = nWinR1
  167.     nRowBot = nWinR2
  168.     nWinC1 = mnWinC1
  169.     nWinC2 = mnWinC2
  170.     nWinR1 = mnWinR1
  171.     nWinR2 = mnWinR2
  172.     do while (nWinC1#nColLeft .or. nWinC2#nColRite .or. ;
  173.         nWinR1 # nRowTop .or. nWinR2 # nRowBot)
  174.         
  175.         * Adjust coordinates for the clear (moving out from the middle)
  176.         nWinR1 = ;
  177.         nWinR1-iif(nRowTop<nWinR1-nAdjRow,nAdjRow,nWinR1-nRowTop)
  178.         nWinR2 = ;
  179.         nWinR2+iif(nRowBot>nWinR2+nAdjRow,nAdjRow,nRowBot-nWinR2)
  180.         nWinC1 = ;
  181.         nWinC1-iif(nColLeft<nWinC1-nAdjCol,nAdjCol,nWinC1-nColLeft)
  182.         nWinC2 = ;
  183.         nWinC2+iif(nColRite>nWinC2+nAdjCol,nAdjCol,nColRite-nWinC2)
  184.         
  185.         * Perform the clear
  186.         @nWinR1,nWinC1 clear to nWinR2,nWinC2
  187.         @nWinR1,nWinC1 to nWinR2,nWinC2
  188.     enddo
  189.     clear
  190.     
  191. RETURN   
  192. *-- EoP: JazClear
  193.  
  194. PROCEDURE Wipe
  195. *-------------------------------------------------------------------------------
  196. *-- Programmer..: Alan D. Frazier (CALLAE)
  197. *-- Date........: 01/10/1992
  198. *-- Notes.......: Used to wipe a window from left to right. Nice effect.
  199. *--               Parameters are the coordinates of the window ...
  200. *-- Written for.: dBASE IV, 1.1
  201. *-- Rev. History: None
  202. *-- Calls.......: None
  203. *-- Called by...: Any
  204. *-- Usage.......: do Wipe with <nULRow>,<nULCol>,<nBRRow>,<nBRCol>
  205. *-- Example.....: define window test from 5,10 to 20,70
  206. *--               activate window test
  207. *--                   *-- do stuff in window
  208. *--               do Wipe with 5,10,20,70
  209. *-- Returns.....: None
  210. *-- Parameters..: nULRow = Upper (Left) Row
  211. *--               nULCol = (Upper) Left Column
  212. *--               nBRRow = Bottom (Right) Row
  213. *--               nBRCol = (Bottom) Right Column
  214. *-------------------------------------------------------------------------------
  215.  
  216.     parameter nULRow,nULCol,nBRRow,nBRCol
  217.  
  218.     private nULRow,nULCol,nBRRow,nBRCol,nCurLeft
  219.  
  220.     nCurLeft = 0    && always start at column 0 within the window
  221.     nBRRow  = nBRRow - nULRow - 2
  222.     nBRCol =  nBRCol - nULCol - 2
  223.  
  224.     do while nCurLeft+2 < nBRCol
  225.         @ 0,nCurLeft clear to nBRRow,nCurLeft + 2
  226.         nCurLeft = nCurLeft  + 2
  227.    enddo
  228.  
  229.    @ 0,nBRCol-2 CLEAR TO nBRRow,nBRCol - 1
  230.  
  231. RETURN
  232. *-- EoP: Wipe
  233.  
  234. PROCEDURE Center
  235. *-------------------------------------------------------------------------------
  236. *-- Programmer..: Miriam Liskin
  237. *-- Date........: 05/24/1991
  238. *-- Notes.......: Centers text on the screen with @says
  239. *-- Written for.: dBASE IV, 1.1
  240. *-- Rev. History: This and all other procedures/functions listed in this
  241. *--               file attributed to Miriam Liskin came from "Liskin's
  242. *--               Programming dBASE IV Book". Very good, worth the money.
  243. *-- Calls.......: None
  244. *-- Called by...: Any
  245. *-- Usage.......: do center with <nLine>,<nWidth>,"<cColor>","<cText>"
  246. *-- Example.....: do center with 5,65,"RG+/GB","WARNING! This will blow up!"
  247. *--                  Note that the color field may be blank: ""
  248. *-- Returns.....: None
  249. *-- Parameters..: nLine  = Line or Row for @/Say
  250. *--               nWidth = Width of screen
  251. *--               cColor = Colors to be used ("Forg/Back") (may be nul "", in
  252. *--                           order to use the default colors of window/screen)
  253. *--               cText  = Message to center on screen
  254. *-------------------------------------------------------------------------------
  255.     
  256.     parameters nLine,nWidth,cColor,cText
  257.     private nCol
  258.     
  259.     nCol = (nWidth - len(cText)) /2
  260.     @nLine,nCol say cText color &cColor.
  261.     
  262. RETURN
  263. *-- EoP: Center
  264.  
  265. FUNCTION Surround
  266. *-------------------------------------------------------------------------------
  267. *-- Programmer..: Miriam Liskin
  268. *-- Date........: 05/24/1991
  269. *-- Notes.......: Displays a message surrounded by a box anywhere on 
  270. *--               the screen
  271. *-- Written for.: dBASE IV, 1.1
  272. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (KENMAYER) to a function
  273. *--               from original procedure
  274. *-- Calls.......: None
  275. *-- Called by...: Any
  276. *-- Usage.......: surround(<nLine>,<nColumn>,"<cColor>","<cText>")
  277. *-- Example.....: cDummy = surround(5,12,"RG+/GB",;
  278. *--                        "Processing ... Do not Touch!")
  279. *-- Returns.....: Nul/""
  280. *-- Parameters..: nLine   = Line to display "surrounded" message at
  281. *--               nColumn = Column for same (X,Y coordinates for @SAY)
  282. *--               cColor  = Color variable/colors
  283. *--               cText   = Text to be displayed inside box
  284. *-------------------------------------------------------------------------------
  285.     
  286.     parameters nLine,nColumn,cColor,cText
  287.     
  288.     cText = " " + trim(cText) + " "             && add spaces around text
  289.     @nLine-1,nColumn-1 to nLine+1,nColumn+len(cText) double;
  290.         color &cColor.                           && draw box
  291.     @nLine,nColumn say cText color &cColor.  && disp. text
  292.     
  293. RETURN "" 
  294. *-- EoF: Surround()
  295.  
  296. FUNCTION Message1
  297. *-------------------------------------------------------------------------------
  298. *-- Programmer..: Miriam Liskin
  299. *-- Date........: 05/24/1991
  300. *-- Notes.......: Displays a message, centered at whatever line you give,
  301. *--               pauses until user presses a key.
  302. *-- Written for.: dBASE IV, 1.1
  303. *-- Rev. History: 04/19/1991 Modified by Ken Mayer (KENMAYER) from Miriam's 
  304. *--                procedure to function
  305. *-- Calls.......: CENTER               Procedure in PROC.PRG
  306. *-- Called by...: Any
  307. *-- Usage.......: message1(<nLine>,<nWidth>,"<cColor>","<cText>")
  308. *-- Example.....: cDummy = Message1(5,12,"RG+/GB","All Done.")
  309. *-- Returns.....: numeric value of key pressed by user (cUser)
  310. *-- Parameters..: nLine  = Line to display message
  311. *--               nWidth = Width of screen
  312. *--               cColor = Colors for display
  313. *--               cText  = Text to be displayed.
  314. *-------------------------------------------------------------------------------
  315.  
  316.     parameters nLine,nWidth,cColor,cText
  317.     private cCursor, cUser
  318.     
  319.     @nLine,0
  320.     cCursor = set("CURSOR")  && store current state of CURSOR
  321.     set cursor off           && turn it off
  322.     do center with nLine,nWidth,cColor,cText
  323.     cUser = inkey(0)
  324.     set cursor &cCursor      && set cursor to original state
  325.     @nLine,0                 && erase line ...
  326.  
  327. RETURN cUser
  328. *-- EoF: Message1()
  329.  
  330. FUNCTION Message2
  331. *-------------------------------------------------------------------------------
  332. *-- Programmer..: Miriam Liskin
  333. *-- Date........: 06/08/1992
  334. *-- Notes.......: Displays a message in a window, pauses for user to 
  335. *--               press key
  336. *-- Written for.: dBASE IV, 1.1
  337. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (KENMAYER) to a function
  338. *--               04/29/1991 - Modified by Ken Mayer (KENMAYER) to add shadow
  339. *--               06/08/1992 - Modified by same, to do EXPLICIT setting of
  340. *--               colors for window used.
  341. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  342. *--               CENTER               Procedure in PROC.PRG
  343. *-- Called by...: Any
  344. *-- Usage.......: message2("<cText>","<cColor>")
  345. *-- Example.....: cDummy = message2("Finished Processing!",;
  346. *--                         "RG+/GB,,RG+/GB")
  347. *-- Returns.....: numeric value of key pressed by user (cUser)
  348. *-- Parameters..: cText  = Text to be displayed in window
  349. *--               cColor = Colors for window
  350. *-------------------------------------------------------------------------------
  351.  
  352.     parameters cText,cColor
  353.     private cCursor, cUser
  354.     
  355.     cCursor = set("CURSOR")
  356.     set cursor off
  357.     save screen to sMessage
  358.     
  359.     *-- NOW we see what happens ...
  360.     activate screen
  361.     define window wMessage from 10,10 to 14,70 double color &cColor
  362.     do shadow with 10,10,14,70
  363.     activate window wMessage
  364.     
  365.     do center with 1,60,"",cText
  366.     wait "" to cUser
  367.     
  368.     *-- cleanup
  369.     set cursor &cCursor
  370.     
  371.     *-- remove window ...
  372.     deactivate window wMessage
  373.     release window wMessage
  374.     restore screen from sMessage
  375.     release screen sMessage
  376.  
  377. RETURN cUser
  378. *-- EoF: Message2()
  379.  
  380. FUNCTION Message3
  381. *-------------------------------------------------------------------------------
  382. *-- Programmer..: Miriam Liskin
  383. *-- Date........: 06/08/1992
  384. *-- Notes.......: Displays a message in a window, pauses for user, 
  385. *--               will wrap a long message inside the window.
  386. *-- Written for.: dBASE IV, 1.1
  387. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (KENMAYER) to a function
  388. *--               04/29/1991 - Modified to Ken Mayer (KENMAYER) add shadow
  389. *--               06/08/1992 - Modified to explicitly set the colors ...
  390. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  391. *-- Called by...: Any
  392. *-- Usage.......: Message3("<cText>","<cColor>")
  393. *-- Example.....: cDummy = Message3("This is a long message that will be"+;
  394. *--                 "wrapped around inside the window.","rg+/gb,,rg+/gb")
  395. *-- Returns.....: numeric value of key used to exit window (cUser)
  396. *-- Parameters..: cText  = Text to be displayed
  397. *--               cColor = Colors for window
  398. *-------------------------------------------------------------------------------
  399.  
  400.     parameters cText,cColor
  401.     private nLines,cCursor,cUser,nLMargin,nRMargin,cAlignment,lWrap
  402.     
  403.     nLines = int(len(cText) / 38) + 5    && set # of lines for window
  404.     
  405.     cCursor = set("CURSOR")
  406.     set cursor off
  407.     save screen to sMessage
  408.     
  409.     *-- define/activate window
  410.     activate screen
  411.     define window wMessage from 8,20 to 8+nLines,60 double color &cColor
  412.     do shadow with 8,20,8+nLines,60
  413.     activate window wMessage
  414.     
  415.     nLmargin   = _lmargin
  416.     nRmargin   = _rmargin
  417.     cAlignment = _alignment
  418.     lWrap      = _wrap
  419.     
  420.     _lmargin   = 1 
  421.     _rmargin   = 38
  422.     _alignment = "CENTER"
  423.     _wrap      = .t.
  424.     
  425.     ?cText
  426.     ?
  427.     wait "    Press any key to continue . . ." to cUser
  428.     
  429.     _lmargin   = nLmargin
  430.     _rmargin   = nRmargin
  431.     _alignment = cAlignment
  432.     _wrap      = lWrap
  433.     
  434.     set cursor &cCursor
  435.     deactivate window wMessage
  436.     release window wMessage
  437.     restore screen from sMessage
  438.     release screen sMessage
  439.  
  440. RETURN cUser
  441. *-- EoF: Message3()
  442.  
  443. FUNCTION Message4
  444. *-------------------------------------------------------------------------------
  445. *-- Programmer..: Miriam Liskin
  446. *-- Date........: 06/08/1992
  447. *-- Notes.......: Displays a 2-line message in a predefined window 
  448. *--                 and pauses
  449. *-- Written for.: dBASE IV, 1.1
  450. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (KENMAYER) to a function
  451. *--               04/29/1991 - Modified to Ken Mayer (KENMAYER) add shadow
  452. *--               06/08/1992 -- Modified to explicitly deal with colors
  453. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  454. *--               CENTER               Procedure in PROC.PRG
  455. *-- Called by...: Any
  456. *-- Usage.......: message4("<cText1>","<cText2>","<cColor>")
  457. *-- Example.....: cDummy = message4("Finished processing.","There are ";
  458. *--                        +ltrim(str(reccount()))+" Records in this file.",;
  459. *--                        "rg+/rg,rg+/rg,rg+/rg")
  460. *-- Returns.....: numeric value of key pressed by user to exit window (cUser)
  461. *-- Parameters..: cText1 = First line of message
  462. *--               cText2 = Second line of message
  463. *--               cColor = Colors for window
  464. *-------------------------------------------------------------------------------
  465.  
  466.     parameters cText1,cText2,cColor
  467.     private cCursor,cUser,nLMargin,nRMargin,lWrap
  468.     
  469.     cCursor = set("CURSOR")
  470.     set cursor off
  471.     save screen to sMessage
  472.     
  473.     activate screen
  474.     define window wMonitor from 10,10 to 17,70 double color &cColor
  475.     do shadow with 10,10,17,70
  476.     activate window wMonitor
  477.     
  478.     nLmargin = _lmargin
  479.     nRmargin = _rmargin
  480.     lWrap =    _wrap
  481.     _lmargin = 1 
  482.     _rmargin = 58
  483.     _wrap    = .t.
  484.     
  485.     do center with 1,58,"",cText1
  486.     do center with 2,58,"",cText2
  487.     do center with 4,58,"","Press any key to continue . . ."
  488.     wait "" to cUser
  489.  
  490.     _lmargin = nLmargin
  491.     _rmargin = nRmargin
  492.     _wrap    = lWrap
  493.     set cursor &cCursor
  494.     deactivate window wMonitor
  495.     release window wMonitor
  496.     restore screen from sMessage
  497.     release screen sMessage
  498.     
  499. RETURN cUser
  500. *-- EoF: Message4()
  501.  
  502. PROCEDURE Monitor
  503. *-------------------------------------------------------------------------------
  504. *-- Programmer..: Miriam Liskin
  505. *-- Date........: 06/08/1992
  506. *-- Notes.......: Displays a status message to monitor a long-running 
  507. *--                 operation that operates on multiple records . . . 
  508. *--                 Should be used with MONITOROFF (below) to cleanup.
  509. *-- Written for.: dBASE IV, 1.1
  510. *-- Rev. History: 04/29/1991 - Modified by Ken Mayer (KENMAYER) to add shadow
  511. *--               06/08/1992 - Modified to handle explicit color setting
  512. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  513. *--               CENTER               Procedure in PROC.PRG
  514. *-- Called by...: Any
  515. *-- Usage.......: do monitor with "<cText>","<cColor>"
  516. *-- Example.....: do monitor with "Processing REPORT.DBF","rg+/gb,rg+/gb,rg+/gb"
  517. *--               nRec = 0
  518. *--               do while  && (or SCAN)
  519. *--                  && stuff -- process records
  520. *--                  nRec = nRec + 1
  521. *--                  @4,30 display ltrim(str(nRec)) && current record
  522. *--                                                 && in window MONITOR
  523. *--               enddo  && (or endscan)
  524. *--               do MonitorOff  && procedure to clean-up after this one
  525. *-- Returns.....: None
  526. *-- Parameters..: cText  = Text to display
  527. *--               cColor = Colors for window
  528. *-------------------------------------------------------------------------------
  529.  
  530.     parameters cText,cColor
  531.     private cTempCol
  532.     
  533.     save screen to sMonitor
  534.     activate screen
  535.     define window wMonitor From 10,10 to 18,70 double color &cColor
  536.     do shadow with 10,10,18,70
  537.     activate window wMonitor
  538.     
  539.     do center with 1,60,"",cText
  540.     do center with 2,60,"","Please do not interrupt"
  541.     @4,10 say "Working on record          of " + ltrim(str(reccount(),5))
  542.     
  543. RETURN
  544. *-- EoP: Monitor
  545.  
  546. PROCEDURE MonitorOff
  547. *-------------------------------------------------------------------------------
  548. *-- Programmer..: Ken Mayer (KENMAYER)
  549. *-- Date........: 05/23/1991
  550. *-- Notes.......: Used to deal with ending routines for MONITOR
  551. *--                 procedure above.
  552. *-- Written for.: dBASE IV, 1.1
  553. *-- Rev. History: None
  554. *-- Calls.......: None
  555. *-- Called by...: Routine using MONITOR  Procedure in PROC.PRG
  556. *-- Usage.......: do monitoroff
  557. *-- Example.....: do monitoroff
  558. *-- Returns.....: None
  559. *-- Parameters..: None
  560. *-------------------------------------------------------------------------------
  561.  
  562.     deactivate window wMonitor
  563.     release window wMonitor
  564.     restore screen from sMonitor
  565.     release screen sMonitor
  566.     
  567. RETURN
  568. *-- EoP: MonitorOff
  569.  
  570. FUNCTION ScrnHead
  571. *-------------------------------------------------------------------------------
  572. *-- Programmer..: Miriam Liskin
  573. *-- Date........: 05/23/1991
  574. *-- Notes.......: Displays a heading on the screen in a box 2 
  575. *--               spaces wider than the text, with a custom border (double 
  576. *--               line top, single the rest)
  577. *-- Written for.: dBASE IV, 1.1
  578. *-- Rev. History: 4/29/1991 - Modified by Ken Mayer (KENMAYER) to add shadow
  579. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  580. *-- Called by...: Any
  581. *-- Usage.......: scrnhead("<cColor>","<cText>")
  582. *-- Examples....: cDummy = ScrnHead("rg+/gb","Print Financial Report")
  583. *-- Returns.....: nul/""
  584. *-- Parameters..: cColor = Colors to display box/text in
  585. *--               cText  = text to be displayed.
  586. *-------------------------------------------------------------------------------
  587.  
  588.     parameters cColor,cText
  589.     private cTextStart,cText2
  590.     
  591.     cText2 = " "+trim(cText)+" "             && ad spaces to left and right
  592.     cTextstart = (80-len(trim(cText2)))/2
  593.     activate screen
  594.     do shadow with 1,cTextstart-1,3,81-cTextstart
  595.     @1,cTextstart-1 to 3,81-cTextstart 205,196,179,179,213,184,192,217;
  596.         color &cColor.                           && display box
  597.     @2, cTextstart say cText2 color &cColor. && display text
  598.  
  599. RETURN ""
  600. *-- EoF: ScrnHead()
  601.  
  602. FUNCTION YesNo
  603. *-------------------------------------------------------------------------------
  604. *-- Programmer..: Miriam Liskin
  605. *-- Date........: 06/08/1992
  606. *-- Notes.......: Asks a yes/no question in a dialog window/box
  607. *-- Written for.: dBASE IV, 1.1
  608. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
  609. *--               04/29/1991 - Modified by Ken Mayer add shadow
  610. *--               05/13/1991 - Modified by Ken Mayer remove need for extra 
  611. *--                            procedures (YES/NO) that were used for returning
  612. *--                            values from Menu
  613. *--                            (suggested by Clinton L. Warren (VBCES))
  614. *--               01/20/1992 - Modified by Martin Leon (HMan) to handle user
  615. *--                            pressing 'Y' or 'N' keys (with ON KEY ...).
  616. *--               04/22/1992 - Modified by Ken Mayer adding CLEAR TYPEAHEAD,
  617. *--                            as occaisional problems appear otherwise.
  618. *--               06/08/1992 - Modified (Ken Mayer) to deal with explicit
  619. *--                            color processing.
  620. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  621. *--               CENTER               Procedure in PROC.PRG
  622. *-- Called by...: Any
  623. *-- Usage.......: yesno(<lAnswer>,"<cMess1>","<cMess2>","<cMess3>","<cColor>")
  624. *-- Example.....: if YesNo(.t.,"Do You Really Wish To Delete?",;
  625. *--                            "This will destroy the data";
  626. *--                             "in this record.";
  627. *--                             "rg+/gb,n/w,rg+/gb")
  628. *--                  delete
  629. *--               else
  630. *--                  skip
  631. *--               endif
  632. *--
  633. *--                 The middle set of colors should be different, as they
  634. *--                 will be the colors of the YES/NO selections ...
  635. *--                 Options may be blank by using nul values ("")
  636. *-- Returns.....: .t./.f. depending on user's choice from menu
  637. *-- Parameters..: lAnswer = default value (Yes or No) for menu
  638. *--               cMess1  =  First line of Message
  639. *--               cMess2  =  Second line of message
  640. *--               cMess3  =  Third line of message
  641. *--               cColor  =  Colors for window/menu/box
  642. *-------------------------------------------------------------------------------
  643.  
  644.     parameter lAnswer,cMess1,cMess2,cMess3,cColor
  645.     private nLMargin,nRMargin,lWrap
  646.     
  647.     save screen to sYesno
  648.     activate screen
  649.     define window wYesno from 8,20 to 15,60 double color &cColor
  650.     
  651.     define menu mYesno
  652.     *-- remove && from MESSAGE option if using or might be used on Mono system
  653.     define pad pYes of mYesno Prompt "[Yes]" at 5,10 && message "Yes"
  654.     define pad pNo  of mYesno Prompt "[No]"  at 5,25 && message "No"
  655.     on selection pad pYes of mYesno deactivate menu
  656.     on selection pad pNo  of mYesno deactivate menu
  657.     
  658.     do shadow with 8,20,15,60
  659.     activate window wYesno
  660.     nLmargin = _lmargin    && store system values
  661.     nRmargin = _rmargin
  662.     lWrap    = _wrap
  663.     _lmargin   = 2            && set local values
  664.     _rmargin   = 38
  665.     _wrap      = .t.
  666.     
  667.     do center with 0,38,"",cMess1        && center the text
  668.     do center with 2,38,"",cMess2
  669.     do center with 3,38,"",cMess3
  670.  
  671.     *-- deal with user pressing 'Y' or 'N' ...
  672.    on key label Y keyboard IIF( PAD() = "PYES", "", CHR(19) )+chr(13)
  673.    on key label N keyboard IIF( PAD() = "PNO",  "", CHR(4)  )+chr(13)
  674.     *-- otherwise deal with regular "menu" abilities
  675.     clear typeahead
  676.    if lAnswer
  677.         activate menu mYesno pad pYes
  678.     else
  679.         activate menu mYesno pad pNo
  680.     endif
  681.     
  682.     *-- clear out ON KEY settings ...
  683.    on key label Y
  684.    on key label N
  685.     _lmargin = nLmargin    && reset system values
  686.     _rmargin = nRmargin
  687.     _wrap    = lWrap
  688.     deactivate window wYesno
  689.     release window wYesno
  690.     restore screen from sYesno
  691.     release screen sYesno
  692.     release menu mYesno
  693.  
  694. RETURN iif(pad()="PYES",.t.,.f.)
  695. *-- EoF: YesNo()
  696.  
  697. FUNCTION YesNo2
  698. *-------------------------------------------------------------------------------
  699. *-- Programmer..: Miriam Liskin
  700. *-- Date........: 06/08/1992
  701. *-- Notes.......: Asks a yes/no question in a dialog window/box
  702. *-- Written for.: dBASE IV, 1.1
  703. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
  704. *--               04/29/1991 - Modified by Ken Mayer add shadow
  705. *--               05/13/1991 - Modified by Ken Mayer remove need for extra 
  706. *--                            procedures (YES/NO) that were used for returning
  707. *--                            values from Menu
  708. *--                            (suggested by Clinton L. Warren (VBCES))
  709. *--               11/15/1991 - Copied YesNo, modified to allow "location" 
  710. *--                            options -- useful for some screens ...
  711. *--               01/20/1992 - Modified by Martin Leon (HMAN) to allow user to
  712. *--                            press 'Y' or 'N' and have them recognized ...
  713. *--               04/22/1992 - Modified by Ken Mayer adding CLEAR TYPEAHEAD,
  714. *--                            as occaisional problems appear otherwise.
  715. *--               06/08/1992 - Modified by same for explicit color sets.
  716. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  717. *--               CENTER               Procedure in PROC.PRG
  718. *-- Called by...: Any
  719. *-- Usage.......: yesno2(<lAnswer>,"<cWhere>",;
  720. *--                                "<cMess1>","<cMess2>","<cMess3>","<cColor>")
  721. *-- Example.....: if YesNo2(.t.,"UL","Do You Really Wish To Delete?",;
  722. *--                            "This will destroy the data";
  723. *--                             "in this record.";
  724. *--                             "rg+/gb,n/w,rg+/gb")
  725. *--                  delete
  726. *--               else
  727. *--                  skip
  728. *--               endif
  729. *--
  730. *--                 The middle set of colors should be different, as they
  731. *--                 will be the colors of the YES/NO selections ...
  732. *--                 Options may be blank by using nul values ("")
  733. *-- Returns.....: .t./.f. depending on user's choice from menu
  734. *-- Parameters..: lAnswer = default value (Yes or No) for menu
  735. *--               cWhere  = location on screen:
  736. *--                            "UL" = Upper Left
  737. *--                            "UC" = Upper Center
  738. *--                            "UR" = Upper Right
  739. *--                            "CL" = Center Left
  740. *--                            "CC" = Center Center
  741. *--                            "CR" = Center Right
  742. *--                            "BL" = Bottom Left
  743. *--                            "BC" = Bottom Center
  744. *--                            "BR" = Bottom Right
  745. *--               cMess1  =  First line of Message
  746. *--               cMess2  =  Second line of message (may be nul = "")
  747. *--               cMess3  =  Third line of message  (may be nul = "")
  748. *--               cColor  =  Colors for window/menu/box
  749. *-------------------------------------------------------------------------------
  750.  
  751.     parameter lAnswer,cWhere,cMess1,cMess2,cMess3,cColor
  752.     private cExact,cW1,cW2,nULB,nBRR,nULC,nBRC,nLMargin,nRMargin,lWrap
  753.         
  754.     cExact = set("EXACT")
  755.     save screen to sYesno
  756.     
  757.     *-- see what the user gave us ...
  758.     if len(trim(cWhere)) > 0
  759.         cW1 = upper(left(cWhere,1))  && first coordinate (vertical)
  760.         cW2 = upper(right(cWhere,1)) && second coordinate (horizontal)
  761.     else
  762.         cW1 = "C"
  763.         cW2 = "C"
  764.     endif
  765.     *-- deal with vertical placement
  766.     do case
  767.         case cW1 = "U"
  768.             nULR =  1   && upper left row
  769.             nBRR =  8   && bottom right row
  770.         case cW1 = "C"
  771.             nULR =  8
  772.             nBRR = 15
  773.         case cW1 = "B"
  774.             nULR = 15
  775.             nBRR = 22
  776.     endcase
  777.     *-- deal with horizontal placement
  778.     do case
  779.         case cW2 = "L"
  780.             nULC =  5   && upper left column
  781.             nBRC = 45   && bottom right column
  782.         case cW2 = "R"
  783.             nULC = 35
  784.             nBRC = 75
  785.         case cW2 = "C"
  786.             nULC = 20
  787.             nBRC = 60
  788.     endcase
  789.     
  790.     activate screen
  791.     define window wYesno from nULR,nULC to nBRR,nBRC double color &cColor
  792.     
  793.     define menu mYesno
  794.     *-- remove && from MESSAGE option if using or might be used on Mono system
  795.     define pad pYes of mYesno Prompt "[Yes]" at 5,10 && message "Yes"
  796.     define pad pNo  of mYesno Prompt "[No]"  at 5,25 && message "No"
  797.     on selection pad pYes of mYesno deactivate menu
  798.     on selection pad pNo  of mYesno deactivate menu
  799.     *-- start displaying it ... shadow, window ...
  800.     do shadow with nULR,nULC,nBRR,nBRC
  801.     activate window wYesno
  802.     *-- store or set some system values
  803.     nLmargin = _lmargin    
  804.     nRmargin = _rmargin
  805.     lWrap    = _wrap
  806.     _lmargin   = 2            && set local values
  807.     _rmargin   = 38
  808.     _wrap      = .t.
  809.     *-- display text
  810.     do center with 0,38,"",cMess1        && center the text
  811.     do center with 2,38,"",cMess2
  812.     do center with 3,38,"",cMess3
  813.     *-- set 'y' or 'n' keys ...
  814.    on key label Y keyboard IIF( PAD() = "PYES", "", CHR(19) )+chr(13)
  815.    on key label N keyboard IIF( PAD() = "PNO",  "", CHR(4)  )+chr(13)
  816.     clear typeahead
  817.    if lAnswer
  818.         activate menu mYesno pad pYes
  819.     else
  820.         activate menu mYesno pad pNo
  821.     endif
  822.    
  823.     *-- reset system ...
  824.     on key label Y
  825.    on key label N
  826.     _lmargin = nLmargin
  827.     _rmargin = nRmargin
  828.     _wrap    = lWrap
  829.     deactivate window wYesno
  830.     release window wYesno
  831.     restore screen from sYesno
  832.     release screen sYesno
  833.     release menu mYesno
  834.     set exact &cExact
  835.     
  836. RETURN iif(pad()="PYES",.t.,.f.)
  837. *-- EoF: YesNo2()
  838.  
  839. FUNCTION ErrorMsg
  840. *-------------------------------------------------------------------------------
  841. *-- Programmer..: Ken Mayer (KENMAYER)
  842. *-- Date........: 06/08/1992
  843. *-- Notes.......: Display an error message in a Window: 
  844. *--                           ** ERROR [#] **
  845. *--
  846. *--                              Message 1
  847. *--                              Message 2
  848. *--                       Press any key to continue ...
  849. *-- Written for.: dBASE IV, 1.1
  850. *-- Rev. History: 06/08/1992 -- Modified for explicit color handing.
  851. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  852. *--               CENTER               Procedure in PROC.PRG
  853. *--               ALLTRIM()            Function in PROC.PRG
  854. *-- Called by...: Any
  855. *-- Usage.......: ErrorMsg("<cErr>","<cMess1>","<cMess2>","<cColor>")
  856. *-- Example.....: lc_Dummy = errormsg("3","This record","already exists!",;
  857. *--                   "rg+/r,rg+/r,rg+/r")
  858. *--               where "errornum" is an error number or nul,
  859. *--               message2 and 3 should be 36 characters or less ...
  860. *--               Colors should include foreground/background,;
  861. *--                 foreground/background,foreground/background
  862. *-- Returns.....: numeric value of keystroke user presses (cUser)
  863. *-- Parameters..: cErr   = Error # (can be blank, but use "" for blank)
  864. *--               cMess1 = Error message line 1
  865. *--               cMess2 = Error message line 2
  866. *--               cColor = Colors for text/window/border
  867. *-------------------------------------------------------------------------------
  868.     
  869.     parameters cErr,cMess1,cMess2,cColor
  870.     private cCursor,cUser,cCurColor,cTempCol
  871.     
  872.     save screen to sErr
  873.     activate screen
  874.     define window wErr from 8,20 to 15,60 double color &cColor
  875.     do shadow with 8,20,15,60
  876.     activate window wErr
  877.     
  878.     cCursor = set("CURSOR")
  879.     set cursor off
  880.     if len(trim(cErr)) > 0  && if there's an error number ...
  881.         do center with 0,38,"","** ERROR "+alltrim(cErr)+" **"
  882.     else                      && otherwise, don't display errornumber
  883.         do center with 0,38,"","** ERROR **"
  884.     endif
  885.     do center with 2,38,"",cMess1
  886.     do center with 3,38,"",cMess2
  887.     do center with 5,38,"","Press any key to continue ..."
  888.     cUser=inkey(0)
  889.     
  890.     set cursor &cCursor
  891.     deactivate window wErr
  892.     release window wErr
  893.     restore screen from sErr
  894.     release screen sErr
  895.     
  896. RETURN cUser
  897. *-- EoF: ErrorMsg()
  898.  
  899. PROCEDURE Shadow
  900. *-------------------------------------------------------------------------------
  901. *-- Programmer..: Ashton-Tate
  902. *-- Date........: 01/27/1992
  903. *-- Notes.......: Creates a shadow for a window (taken from the dBASE IV
  904. *--               picklist functions)
  905. *-- Written for.: dBASE IV, 1.1
  906. *-- Rev. History: 05/23/1991 - original procedure.
  907. *--               12/14/1991 - Modified by Jim Magnant (TXAGGIE) - to check
  908. *--               for columns exceeding 79, and temporarily change last col.
  909. *--               value (so routine doesn't "blow up").
  910. *--               01/27/1992 -- Modifiedy by Ken Mayer to check for bottom
  911. *--               of screen, based on what Jim did above. No further than 23.
  912. *-- Calls.......: None
  913. *-- Called by...: Too many to list ...
  914. *-- Usage.......: do shadow with <nULRow>,<nULCol>,<nBRRow>,<nBRCol>
  915. *-- Example.....: save screen to sMain
  916. *--               activate screen
  917. *--               define window wError from 5,15 to 15,65 double color;
  918. *--                    rg+/r,rg+/r,rg+/r
  919. *--               do shadow with 5,15,15,65
  920. *--               activate window WError
  921. *--                && perform actions in window
  922. *--               deactivate window WError
  923. *--               release window WError
  924. *--               restore screen from sMain
  925. *--               release screen sMain
  926. *-- Returns.....: None
  927. *-- Parameters..: nULRow = Upper Left Row position
  928. *--               nULCol = Upper Left Column position (x,y)
  929. *--               nBRRow = Bottom Right Row position
  930. *--               nBRCol = Bottom Right Column position (x2,y2)
  931. *-------------------------------------------------------------------------------
  932.  
  933.     parameters nULRow,nULCol,nBRRow,nBRCOL
  934.     private nTempRow,nTempCol,nIncRow,nIncCol
  935.  
  936.     nTempRow = iif(nBRRow+1>23,23,nBRRow+1)
  937.     nTempCol = iif(nBRCol+2>79,79,nBRCol+2)
  938.     nIncRow = 1
  939.     nIncCol = (nBRCol-nULCol) / (nBRRow-nULRow)
  940.     do while nTempRow <> nULRow .or. nTempCol <> nULCol+2
  941.         nRightCol = nBRCol
  942.         nBRCol = iif(nBRCol + 2 > 79,77,nBRCol)
  943.         nBotRow = nBRRow
  944.         nBRRow = iif(nBRRow + 1 > 23,22,nBRRow)
  945.         @ nTempRow,nTempCol fill to nBRRow+1,nBRCol+2 color n+/n
  946.         nBRCol = nRightCol
  947.         nBRRow = nBotRow
  948.         nTempRow = iif(nTempRow<>nULRow,nTempRow - nIncRow,nTempRow)
  949.         nTempCol = iif(nTempCol<>nULCol+2,nTempCol - nIncCol,nTempCol)
  950.         nTempCol = iif(nTempCol<nULCol+2,nULCol+2,nTempCol)
  951.     enddo
  952.     
  953. RETURN
  954. *-- EoP: Shadow
  955.  
  956. FUNCTION VPick
  957. *-------------------------------------------------------------------------------
  958. *-- Programmer...: Keith G. Chuvala (KGC)
  959. *-- Date.........: 06/08/1992
  960. *-- Notes........: Keith wanted a multiple choice picklist routine for use
  961. *--                with a mouse (or other) ... he got the idea for the AT-USER
  962. *--                system which he was Beta Testing. Here 'tis ...
  963. *--                 This creates a quick pick-list for multiple-choice, single-
  964. *--                 character input. The first letter of the selected bar is
  965. *--                 returned. If <Esc> is pressed, a null string is returned.
  966. *--                NOTE: If using this with dBASE IV, 1.1, you must supply
  967. *--                a parameter for each option below.
  968. *-- Written for..: dBASE IV, 1.5
  969. *-- Rev. History.: 06/02/1992 -- Keith first gave this to Ken Mayer to use with
  970. *--                the BORUSER system.
  971. *--                06/08/1992 -- Modified to allow passing of a color memvar,
  972. *--                and then to use explicit color definitions based on it.
  973. *-- Calls........: COLORBRK()          Function in PROC.PRG
  974. *--                RECOLOR             Procedure in PROC.PRG
  975. *-- Called by....: Any
  976. *-- Usage........: ?VPick(<nRow>,<nCol>,"<cOptions>","<cTitle>","<cMessage>",;
  977. *--                 <lShadow>,<cColor>)
  978. *-- Example......: cHow = VPick(12,15,"~BorBBS ID~Lastname",;
  979. *--                         "How do you want the data sorted?","Choose one",;
  980. *--                         "rg+/gb,w+/b,rg+/gb")
  981. *-- Returns......: First letter of bar selected, or null if <Esc>.
  982. *-- Parameters...: nRow     = is a numeric value for the top row of the popup.
  983. *--                nCol     = is a numeric value for the left column.
  984. *--                cOptions = is a string of options with each preceded by
  985. *--                        '~', e.g. "~Screen~Printer~Text File~Return to Menu"
  986. *--                cTitle   = is an optional title, used for the popup heading
  987. *--                cMessage = is an optional message string for when the popup 
  988. *--                           is activated on the screen.
  989. *--                lShadow  = is a logical value indicating whether or not a 
  990. *--                           shadow is to be placed under the popup.
  991. *--                cColor   = Colors to be used. Should have three parts --
  992. *--                           <normal/unselected text>,<highlighted text>,
  993. *--                           <border>, using the format "Foreground/Background"
  994. *--                           for each. So examine the example above.
  995. *-------------------------------------------------------------------------------
  996.     
  997.     parameters nRow,nCol,cOptions,cTitle,cMessage,lShadow,cColor
  998.     private nRow,nCol,cOptions,cTitle,cMessage,lShadow,cTempCol,cCurColor
  999.     
  1000.     *-- get number of parameters, and a few setup steps ...
  1001.     if val(right(version(),3)) > 1.1  && if version of dBASE (RunTime) > 1.1
  1002.        nParameters = pcount()
  1003.     else
  1004.         nParameters = 7
  1005.     endif
  1006.    nCount = 0
  1007.    cReturn = ""
  1008.    cOptions = trim(cOptions)
  1009.    cDispMesg = ""
  1010.    *-- if number of parameters greater/equal to 5, we may have a message
  1011.    *-- at the bottom of the screen ...
  1012.    if nParameters >= 5
  1013.       if len(cMessage) > 0
  1014.          cDispMesg = "MESSAGE "+"'"+cMessage+"'"
  1015.       endif
  1016.    endif
  1017.    *-- define the popup
  1018.    define popup pPickList from nRow,nCol &cDispMesg.
  1019.    nMessage1 = 0
  1020.    *-- if we have 4 or more parameters, one of them is the title ...
  1021.    *-- this requires that the first two bars of the menu be skipped ...
  1022.    if nParameters >= 4
  1023.       if len(cTitle) > 0
  1024.          cTitle = " "+cTitle+" "
  1025.          nMessage1 = len(cTitle)
  1026.          nCount = 2
  1027.       endif
  1028.    endif
  1029.  
  1030.     *-- save current colors
  1031.     cCurColor = set("ATTRIBUTES")
  1032.     *-- set new ones
  1033.     cTempCol = colorbrk(cColor,1)
  1034.     set color of normal  to &cTempCol
  1035.     set color of message to &cTempCol
  1036.     cTempCol = colorbrk(cColor,2)
  1037.     set color of highlight to &cTempCol
  1038.     cTempCol = colorbrk(cColor,3)
  1039.     set color of box to &cTempCol
  1040.     
  1041.    *-- now we start parsing the options for the menu. These must have
  1042.    *-- a tilde between each, so we look for the first one, and then
  1043.    *-- look again to see if there's another after that.
  1044.  
  1045.    nPos1 = at("~",cOptions)                        && Look for first tilde
  1046.    do while (len(cOptions) > 0) .and. (nPos1 > 0)  && parsing loop ...
  1047.       if nPos1 > 0
  1048.          cSub = substr(cOptions,nPos1+1,len(cOptions)-nPos1)
  1049.          nPos2 = at("~",cSub)
  1050.          if nPos2 = 0
  1051.             nPos2 = len(cSub)
  1052.          else
  1053.             nPos2 = nPos2 - 1
  1054.          endif
  1055.          cOptString = " "+left(cSub,nPos2)+" "
  1056.          if len(cOptString) > nMessage1
  1057.             nMessage1 = len(cOptString)
  1058.          endif
  1059.          *-- define the actual 'bar' of the menu/picklist ...
  1060.          nCount = nCount + 1
  1061.          define bar nCount of pPickList prompt cOptString
  1062.          cOptions = cSub
  1063.       endif
  1064.       nPos1 = at("~",cOptions)
  1065.    enddo  && end of parsing loop
  1066.  
  1067.    *-- now we deal with defining the actual picklist ...
  1068.    if nCount > 0             && if we have something to put in the list ...
  1069.       if nParameters >= 4    && if we have a title for the top ...
  1070.          if len(cTitle) > 0
  1071.             if len(cTitle) < nMessage1
  1072.                cTitle = trim(ltrim(cTitle))
  1073.                cTitle = space((nMessage1-len(cTitle)) / 2) + cTitle
  1074.             endif
  1075.             define bar 1 of pPickList prompt cTitle skip
  1076.             define bar 2 of pPickList prompt replicate(chr(196),nMessage1) skip
  1077.          endif
  1078.       endif
  1079.       *-- define what to do when a choice is made ...
  1080.       on selection popup pPickList deactivate popup
  1081.       *-- if we have a shadow, let's save screen and do the shadow
  1082.       *-- before popping up the picklist
  1083.         if nParameters => 6
  1084.           if lShadow
  1085.              save screen to sPickScr
  1086.              @ nRow+1,nCol+2 fill to nRow+nCount+2,nCol+nMessage1+3 color w/n
  1087.           endif
  1088.         else
  1089.             lShadow = .f.
  1090.         endif
  1091.       *-- there we are ...
  1092.       activate popup pPickList
  1093.  
  1094.       *-- cleanup
  1095.       if lShadow
  1096.         restore screen from sPickScr
  1097.         release screen sPickScr
  1098.       endif
  1099.  
  1100.       *-- deal with what to 'return' ...
  1101.       if lastkey() = 27
  1102.          cReturn = ""
  1103.       else
  1104.          cReturn = substr(prompt(),2,1)
  1105.       endif
  1106.  
  1107.    endif && nCount > 0
  1108.  
  1109.     *-- we're done with it ... return it back to the electronic byte storage
  1110.     *-- bins ... 
  1111.    release popup pPickList
  1112.     do ReColor with cCurColor
  1113.     
  1114. RETURN cReturn
  1115. *-- EoF: VPick()
  1116.  
  1117. FUNCTION HPick
  1118. *-------------------------------------------------------------------------------
  1119. *-- Programmer..: Keith G. Chuvala (KGC)
  1120. *-- Date........: 06/12/1992
  1121. *-- Notes.......: Creates a horizontal pick list for multiple-choice single-
  1122. *--               character input.  The first letter of the selected pad is 
  1123. *--               returned.  If <ESC> is pressed, a null string is returned.
  1124. *-- Written for.: dBASE IV, 1.1, 1.5
  1125. *-- Rev. History: 06/12/1992 -- Ken Mayer (KENMAYER) -- minor changes
  1126. *--               to add explicit color setting ...
  1127. *-- Calls.......: COLORBRK()           Function in PROC.PRG
  1128. *--               RECOLOR              Procedure in PROC.PRG
  1129. *-- Called by...: Any
  1130. *-- Usage.......: HPICK(<nRow>,<nCol>,"<cOptions>","<cTitle>","<cMessage>";
  1131. *--                     <lShadow>,"<cColor>")
  1132. *-- Example.....: x=HPick(8,5,"~Screen~Printer~Text File~Return to Menu",;
  1133. *--                       "Output Options","Select one, or <Esc> to exit",;
  1134. *--                       .t.,"rg+/gb,w+/b,rg+/gb")
  1135. *-- Returns.....: First letter of selected 'pad', or null if <Esc>.
  1136. *-- Parameters..: nRow      = a numeric value for the top row of the popup.
  1137. *--               nCol      = a numeric value for the left column of the popup.
  1138. *--               cOptions  = a string of options with each preceded by '~',
  1139. *--                           e.g. "~Screen~Printer~Text File~Return to Menu"
  1140. *--               cTitle    = an optional title, used for the popup heading
  1141. *--               cMessage  = an optional message string for when the popup 
  1142. *--                           is activated on the screen.
  1143. *--               lShadow   = a logical value indicating whether or not a 
  1144. *--                           shadow is to be placed under the popup.
  1145. *--               cColor    = Colors passed to function in format:
  1146. *--                            <Text/Unselected Pad>,<Selected Pad>,<Border>
  1147. *-------------------------------------------------------------------------------
  1148.  
  1149.     parameters nRow,nCol,cOptions,cTitle,cMessage,lShadow, cColor
  1150.     private cPickColor,cTempCol
  1151.    *-- get number of parameters, and a few setup steps
  1152.     *-- if version 1.5 or later, # of parms is optional ...
  1153.     if val(right(version(),3)) > 1.1  && if version of dBASE > 1.1
  1154.         nParameters = pcount()
  1155.     else
  1156.         nParameters = 7
  1157.     endif
  1158.    nCount = 0
  1159.    nStartCol = nCol
  1160.    cOptions = trim(cOptions)
  1161.    cDispMess = ""
  1162.     *-- save current colors, set up colors for this routine
  1163.     cPickColor = set("ATTRIBUTES")
  1164.     cTempCol = colorbrk(cColor,1)
  1165.     set color of normal to &cTempCol
  1166.     set color of message to &cTempCol
  1167.     cTempCol = colorbrk(cColor,2)
  1168.     set color of highlight to &cTempCol
  1169.     cTempCol = colorbrk(cColor,3)
  1170.     set color of box to &cTempCol
  1171.     
  1172.    cPadName = "p"
  1173.     *-- if # of parameters => 5, we may have a message at the bottom of the
  1174.     *-- screen ...
  1175.    if nParameters >= 5
  1176.       if len(cMessage) > 0
  1177.          cDispMess = "MESSAGE "+"'"+cMessage+"'"
  1178.       endif
  1179.    endif
  1180.     *-- start defining the menu ...
  1181.    define menu mHPick &cDispMess.
  1182.    if nParameters >= 4
  1183.       if len(cTitle) > 0
  1184.          cTitle = " "+cTitle+" "
  1185.       endif
  1186.    endif
  1187.     
  1188.     *-- here, we have to parse the cOptions field for the tilde "~" character,
  1189.     *-- which is how we know we have a new pad ...
  1190.    nPos1 = at("~",cOptions)                        && position of first tilde
  1191.    do while (len(cOptions) > 0) .and. (nPos1 > 0)  && parsing loop
  1192.       if nPos1 = 0 .and. (len(cOptions) > 0)
  1193.          nPos1 = len(cOptions)
  1194.       endif
  1195.       if nPos1 > 0
  1196.          cSubString = substr(cOptions,nPos1+1,len(cOptions)-nPos1)
  1197.          nPos2 = at("~",cSubString)
  1198.          if nPos2 = 0
  1199.             nPos2 = len(cSubString)
  1200.          else
  1201.             nPos2 = nPos2 - 1
  1202.          endif
  1203.          cOptString = " "+left(cSubString,nPos2)+" "
  1204.          nCount = nCount + 1
  1205.          cPadName = "p"+ltrim(trim(str(nCount)))
  1206.          define pad &cPadName of mHPick prompt cOptString at nRow,nCol
  1207.          nCol = nCol + len(cOptString)
  1208.          on selection pad &cPadName of mHPick deactivate menu
  1209.          cOptions = cSubString
  1210.       endif
  1211.       nPos1 = at("~",cOptions)
  1212.    enddo
  1213.  
  1214.     *-- done figure that out. On to more stuff ...
  1215.    save screen to sPickList
  1216.     *-- do we have a shadow?
  1217.    if lShadow
  1218.       @ nRow,nStartCol+2 fill to nRow+2,nCol+2
  1219.    endif
  1220.     *-- draw border
  1221.    @ nRow-1,nStartCol-1 to nRow+1,nCol
  1222.     *-- display 'title'
  1223.    if len(cTitle) > 0
  1224.       @ nRow-1,nStartCol+1 say cTitle
  1225.    endif
  1226.     *-- start 'er up ...
  1227.    activate menu mHPick
  1228.  
  1229.     *-- that's it ... return screen to it's original
  1230.     *-- state ...
  1231.    restore screen from sPickList
  1232.     release screen sPickList
  1233.     
  1234.     *-- deal with user keystroke/selection ...
  1235.    if lastkey() = 27
  1236.       cReturn = ""
  1237.    else
  1238.       cReturn = substr(prompt(),2,1)
  1239.    endif
  1240.  
  1241.     *-- cleanup.
  1242.    release menu mHPick
  1243.     do ReColor with cPickColor  && reset colors
  1244.  
  1245. RETURN cReturn
  1246. *-- EoF: HPick()
  1247.  
  1248. *===============================================================================
  1249. * COLOR PROCESSING -- These routines handle setting colors, dealing with
  1250. * checking how colors are set, and so on. Anything that's not here is in
  1251. * the library file:  COLOR.PRG.
  1252. *===============================================================================
  1253.  
  1254. PROCEDURE SetColor
  1255. *-------------------------------------------------------------------------------
  1256. *-- Programmer..: Ken Mayer (KENMAYER)
  1257. *-- Date........: 07/24/1992
  1258. *-- Notes.......: This routine is designed set colors of the primary "areas"
  1259. *--               on the screen, based on a color memvar being passed to it.
  1260. *--               This color memvar should contain two sets of colors (normal
  1261. *--               and enhanced). See below for more details. 
  1262. *-- Written for.: dBASE IV, 1.5
  1263. *-- Rev. History: None
  1264. *-- Calls.......: ColorBrk()           Function in PROC.PRG
  1265. *-- Called by...: Any
  1266. *-- Usage.......: do SetColor with <cColorVar>
  1267. *-- Example.....: cOldColor = set("ATTRIBUTES")  && save old colors
  1268. *--               do SetColor with cl_dialog
  1269. *--                 *-- do whatever needs to be done with these colors
  1270. *--               do ReColor with cOldColor      && restore old colors
  1271. *-- Returns.....: None
  1272. *-- Parameters..: cColorVar = Color memvar. This must contain a "normal"
  1273. *--                           color and a "highlight" color in the format:
  1274. *--                           <forg>/<back>,<forg>/<back>
  1275. *--                           i.e., "rg+/gb,w+/b"
  1276. *-------------------------------------------------------------------------------
  1277.  
  1278.     parameters cColorVar
  1279.     private cNormCol,cHighCol
  1280.     
  1281.     cNormCol = colorbrk(cColorVar,1)  && extract "normal" colors
  1282.     cHighCol = colorbrk(cColorVar,2)  && extract "highlight" colors
  1283.     
  1284.     set color of normal    to &cNormCol  && regular screen/text colors
  1285.     set color of messages  to &cNormCol  && messages/menu pads, etc.
  1286.     set color of box       to &cHighCol  && borders
  1287.     set color of fields    to &cHighCol  && data entry fields
  1288.     set color of highlight to &cHighCol  && highlighted items in menus, etc.
  1289.     
  1290. RETURN
  1291. *-- EoP: SetColor
  1292.  
  1293. PROCEDURE ReColor
  1294. *-------------------------------------------------------------------------------
  1295. *-- Programmer..: Jay Parsons (Jparsons)
  1296. *-- Date........: 04/23/1992
  1297. *-- Notes.......: Restores colors to those held in a string of the form
  1298. *--               returned by set("ATTRIBUTE").
  1299. *-- Written for.: dBASE IV, Versions 1.0 - 1.5.
  1300. *-- Rev. History: None
  1301. *-- Calls       : None
  1302. *-- Called by...: Any
  1303. *-- Usage.......: DO ReColor WITH <cColors>
  1304. *-- Example.....: DO Recolor WITH OldColors
  1305. *-- Parameters..: cColors, a string in the form returned by set("ATTRIBUTE").
  1306. *-- Side effects: Changes the screen colors.
  1307. *-------------------------------------------------------------------------------
  1308.  
  1309.   parameters cColors
  1310.   private cThis, cNext, nAt, cLeft, nX, cAreas
  1311.   cAreas = "   NORMHIGHBORDMESSTITLBOX INFOFIEL"
  1312.   cLeft = cColors + ", "
  1313.   nX = 0
  1314.   do while nX < 8
  1315.     nX = nX + 1
  1316.     cThis = substr( cAreas, 4 * nX, 4 )
  1317.     if nX = 3
  1318.       nAt = at( "&", cLeft )
  1319.       cNext = left( cLeft, nAt - 2 )
  1320.       cLeft = substr( cLeft, nAt + 3 )
  1321.       SET COLOR TO , , &cNext
  1322.     else
  1323.       nAt = at( ",", cLeft )
  1324.       cNext = left( cLeft, nAt - 1 )
  1325.       cLeft = substr( cLeft, nAt + 1 )
  1326.       SET COLOR OF &cThis TO &cNext
  1327.     endif
  1328.   enddo
  1329.  
  1330. RETURN
  1331. *-- EoP: ReColor
  1332.  
  1333. FUNCTION ColorBrk
  1334. *-------------------------------------------------------------------------------
  1335. *-- Programmer..: Ken Mayer (KENMAYER)
  1336. *-- Date........: 07/22/1992
  1337. *-- Notes.......: This routine is designed to be used with any of my functions
  1338. *--               and procedures that accept a memory variable for color,
  1339. *--               and use a window. It's purpose is to break that color var
  1340. *--               into it's components (depending on which one the user wants)
  1341. *--               and return those components, so that they can then be used
  1342. *--               in SET COLOR OF ... commands.
  1343. *-- Written for.: dBASE IV, 1.1, 1.5 (written because of 1.5, but will work in
  1344. *--                1.1)
  1345. *-- Rev. History: 07/22/1992 - modified to handle memvars/color strings that
  1346. *--               may have only two parts to them (no <border>...), so that if
  1347. *--               the <nField> parm is 2, we get a valid value.
  1348. *-- Calls.......: None
  1349. *-- Called by...: Any
  1350. *-- Usage.......: ColorBrk(<cColorVar>,<nField>)
  1351. *-- Example.....: set color of normal to ColorBrk(cColor,1)
  1352. *-- Returns.....: Either the field you asked for (1 thru 3) or null string ("").
  1353. *-- Parameters..: cColorVar = Color variable to extract data from
  1354. *--                   Assumes the form: <main color>,<highlight>,<border>
  1355. *--                   Where each part uses: <foreground>/<background> format
  1356. *--                    i.e., rg+/gb,w+/b,rg+/gb
  1357. *--               nField    = Field you want to extract
  1358. *-------------------------------------------------------------------------------
  1359.  
  1360.     parameters cColorVar, nField
  1361.     private cReturn, cExtracted
  1362.     
  1363.     do case
  1364.         case nField = 1
  1365.             cReturn = left(cColorVar,at(",",cColorVar)-1)
  1366.         case nField = 2
  1367.             cExtract = substr(cColorVar,at(",",cColorVar)+1)  && everything to 
  1368.                                                               && right of comma
  1369.             if at(",",cExtract) > 0
  1370.                 cReturn = left(cExtract,at(",",cExtract)-1)    && left of second ,
  1371.             else
  1372.                 cReturn = cExtract
  1373.             endif
  1374.         case nField = 3
  1375.             cExtract = substr(cColorVar,at(",",cColorVar)+1)
  1376.             cReturn = substr(cExtract,at(",",cExtract)+1)
  1377.         otherwise
  1378.             cReturn = ""
  1379.     endcase
  1380.  
  1381. RETURN cReturn
  1382. *-- EoF: ColorBrk()
  1383.  
  1384. *===============================================================================
  1385. * STRING Manipulation. Most of these are in the library file:  STRINGS.PRG
  1386. * The ones here are common to a lot of apps and functions, and are here so
  1387. * that the library STRINGS.PRG need not be called.
  1388. *===============================================================================
  1389.  
  1390. FUNCTION AllTrim
  1391. *-------------------------------------------------------------------------------
  1392. *-- Programmer..: Phil Steele (from PCSDEMO.PRG -- Public Domain)
  1393. *-- Date........: 5/23/1991
  1394. *-- Notes.......: Complete trims edges of field (left and right)
  1395. *-- Written for.: dBASE IV, 1.1
  1396. *-- Rev. History: None
  1397. *-- Calls.......: None
  1398. *-- Called by...: Any
  1399. *-- Usage.......: alltrim(<cString>)
  1400. *-- Example.....: ? alltrim("  Test String  ") 
  1401. *-- Returns.....: Trimmed string, i.e.:"Test String"
  1402. *-- Parameters..: cString = string to be trimmed
  1403. *-------------------------------------------------------------------------------
  1404.     
  1405.     parameters cString
  1406.     
  1407. RETURN ltrim(rtrim(cString))
  1408. *-- EoF: AllTrim()
  1409.  
  1410. FUNCTION State
  1411. *-------------------------------------------------------------------------------
  1412. *-- Programmer..: David G. Franknbach (FRNKNBCH)
  1413. *-- Date........: 04/22/1992
  1414. *-- Notes.......: Validation of state codes -- used to ensure that a user
  1415. *--               doing data entry will enter the proper codes. Added a few
  1416. *--               US Territory codes as well (Puerto Rico, etc.)
  1417. *-- Written for.: dBASE IV, 1.1
  1418. *-- Rev. History: 12/02/1991
  1419. *--               03/11/1992 -- Modified by Ken Mayer (KENMAYER) to handle
  1420. *--               the extra US Territories, and to ensure that the data is
  1421. *--               at least temporarily in upper case when doing the check ...
  1422. *--               04/22/1992 -- Modified by Jay Parsons (JPARSONS) to shorten
  1423. *--               (simplify) the routine by removing the cSTATE2 memvar.
  1424. *-- Calls.......: None
  1425. *-- Called by...: None
  1426. *-- Usage.......: STATE(<cState>)
  1427. *-- Example.....: @5,10 get cState valid required state(cState);
  1428. *--                     error chr(7)+"This is not a valid state code!"
  1429. *-- Returns.....: Logical (.t. if found, .f. otherwise)
  1430. *-- Parameters..: cState = state code to be checked ....
  1431. *-------------------------------------------------------------------------------
  1432.  
  1433.     parameters cState
  1434.     
  1435.     cStateList = "AL|AK|AZ|AR|CA|CO|CT|DE|DC|FL|GA|HI|ID|IL|IN|IA|KS|KY|LA|"+;
  1436.                  "ME|MD|MA|MI|MN|MS|MO|MT|NE|NV|NH|NJ|NM|NY|NC|ND|OH|OK|OR|"+;
  1437.                  "PA|RI|SC|SD|TN|TX|UT|VT|VA|WA|WV|WI|WY|PR|AS|GU|CM|TT|VI|"
  1438.     lOK = upper(cState) $ cStateList
  1439.  
  1440. RETURN lOK
  1441. *-- EoF: State()
  1442.  
  1443. *===============================================================================
  1444. *  DATE HANDLING ROUTINES -- Most of these are now in the library file: 
  1445. *  DATES.PRG (included with this version of PROC). However, a few are below,
  1446. *  as they have become 'standard' routines in many of my systems.
  1447. *===============================================================================
  1448.  
  1449. FUNCTION DateText
  1450. *-------------------------------------------------------------------------------
  1451. *-- Programmer..: Miriam Liskin
  1452. *-- Date........: 05/23/1991
  1453. *-- Notes.......: Display date in format Month, day year (e.g., July 1,1991)
  1454. *-- Written for.: dBASE IV, 1.1
  1455. *-- Rev. History: None
  1456. *-- Calls.......: None
  1457. *-- Called by...: Any
  1458. *-- Usage.......: DateText(<dDate>) 
  1459. *-- Example.....: ? datetext(date())
  1460. *-- Returns.....: July 1, 1991
  1461. *-- Parameters..: dDate = date to be converted
  1462. *-------------------------------------------------------------------------------
  1463.  
  1464.     parameters dDate
  1465.     
  1466. RETURN CMONTH(dDate)+" "+ltrim(str(day(dDate),2))+", "+str(year(dDate),4)
  1467. *-- EoF: DateText()
  1468.  
  1469. FUNCTION DateText2
  1470. *-------------------------------------------------------------------------------
  1471. *-- Programmer..: Miriam Liskin
  1472. *-- Date........: 05/23/1991
  1473. *-- Notes.......: Display date in format day-of-week, Month day, year
  1474. *-- Written for.: dBASE IV, 1.1
  1475. *-- Rev. History: None
  1476. *-- Calls.......: None
  1477. *-- Called by...: Any
  1478. *-- Usage.......: DateText2(<dDate>)
  1479. *-- Example.....: ? DateText2(date())
  1480. *-- Returns.....: Thursday, July 1, 1991
  1481. *-- Parameters..: dDate = date to be converted
  1482. *-------------------------------------------------------------------------------
  1483.  
  1484.     parameters dDate
  1485.     
  1486. RETURN CDOW(dDate)+", "+cmonth(dDate)+" "+;
  1487.        ltrim(str(day(dDate),2))+", "+str(year(dDate),4)
  1488. *-- EoF: DateText2()
  1489.  
  1490. FUNCTION Age
  1491. *-------------------------------------------------------------------------------
  1492. *-- Programmer..: Martin Leon (HMAN)
  1493. *-- Date........: 10/23/91
  1494. *-- Notes.......: Returns age of person, given their birthdate as of DATE(),
  1495. *--               effectively, as of "Today".
  1496. *-- Written for.: dBASE IV, 1.1
  1497. *-- Rev. History: None
  1498. *-- Calls.......: None
  1499. *-- Called by...: Any
  1500. *-- Usage.......: Age(<dBDay>)
  1501. *-- Example.....: ? "Joe is "+ltrim(str(age(dBDay)))+" today ..."
  1502. *-- Returns.....: Numeric value in years
  1503. *-- Parameters..: dBDay = birthdate of person attempting to find age of.
  1504. *-------------------------------------------------------------------------------
  1505.  
  1506.     parameters dBDay
  1507.     private dToday,nYears
  1508.     
  1509.     dToday = date()
  1510.     nYears = year(dToday) - year(dBDay)
  1511.     do case
  1512.         case month(dBDay) > month(dToday)
  1513.             nYears = nYears - 1
  1514.         case month(dBDay) = month(dToday)
  1515.             if day(dBDay) > day(dToday)
  1516.                 nYears = nYears - 1
  1517.             endif
  1518.     endcase
  1519.  
  1520. RETURN nYears
  1521. *-- EoF: Age()
  1522.  
  1523. *===============================================================================
  1524. * FIELD HANDLING ROUTINES -- Unique searches, string manipulation ...
  1525. * The ones left in PROC.PRG are the more commonly used ones. Anything else is
  1526. * in the library file: FIELDS.PRG.
  1527. *===============================================================================
  1528.  
  1529. FUNCTION IsUnique
  1530. *-------------------------------------------------------------------------------
  1531. *-- Programmer..: Clinton L. Warren (VBCES)
  1532. *-- Date........: 04/28/1992
  1533. *-- Notes.......: Checks to see if an index key already exists in the current
  1534. *--               selected database. This function was inspired by Tom
  1535. *--               Woodward's Chk4Dup UDF.
  1536. *-- Written for.: dBASE IV, 1.1
  1537. *-- Rev. History: May 15, 1991 Version 1.1  Added check for zero record database
  1538. *--               May  7, 1991 Version 1.0  Initial 'release'.
  1539. *--               04/28/1992 -- modified for dBASE IV, 1.5 due to 'new'
  1540. *--               behavior (see READ.ME that comes with 1.5). Should function
  1541. *--               fine with 1.1 and 1.0. This change from David Love (DAVIDLOVE).
  1542. *--               NOTE: NEW PARAMETER
  1543. *-- Calls.......: None
  1544. *-- Called by...: Any
  1545. *-- Usage.......: IsUnique(<xValue>,"<cOrder>","<cField>")
  1546. *-- Example.....: @5,5 SAY "SSN: " GET SSN PICTURE "999-99-9999";
  1547. *--                  valid required IsUnique(SSN, "SSN", "SSN");
  1548. *--                  message "Enter a new SSN";
  1549. *--                  error chr(7)+"SSN must be unique!"
  1550. *-- Returns.....: .T./.F.
  1551. *-- Parameters..: xValue = Value (any non-memo type) to check for uniqueness
  1552. *--               cOrder = MDX Tag used to order the database. Must be set for
  1553. *--                        field being checked.
  1554. *--               cField = field name for 'get'.
  1555. *-------------------------------------------------------------------------------
  1556.     
  1557.     parameters xValue, cOrder, cField
  1558.     private nRecNo, nRecCnt, cSetNear, cSetDel, lIsDeleted, cSetOrder
  1559.     private lIsUnique
  1560.     
  1561.     nRecNo = recno()           && store current record number
  1562.     nRecCnt = reccount()       && count records in database
  1563.     
  1564.     if nRecCnt = 0             && empty database, cValue MUST be unique
  1565.        return .t.
  1566.     endif
  1567.     
  1568.     cSetNear = set('NEAR')     && store status of NEAR flag
  1569.     set near off               && set it off
  1570.     cSetDel = set('DELETE')    && store status of DELETE
  1571.     set delete on              && Delete must be ON for this to work
  1572.     lIsDeleted = deleted()     && is current record deleted?
  1573.     delete                     && set delete flag for current record
  1574.     cSetOrder = order()        && store current MDX tag
  1575.     set order to (cOrder)      && set tag to that sent to function
  1576.     
  1577.     if seek(xValue)            && does it exist already?
  1578.        lIsUnique = .f.         &&   if so, it's not unique
  1579.     else                       && otherwise,
  1580.        lIsUnique = .t.         &&   it is.
  1581.     endif
  1582.    
  1583.    set order to (cSetOrder)   && restore changed settings to original settings
  1584.    set delete &cSetDel
  1585.    set near &cSetNear
  1586.    
  1587.    if nRecNo > nRecCnt        && if called during an append
  1588.       go bottom               && goto the bottom of the database,
  1589.       skip 1                  &&   plus one record (the new one)
  1590.       if lIsUnique            && this is the new part ...
  1591.          replace &cField with xValue
  1592.       endif
  1593.    else
  1594.       go nRecNo               && otherwise, goto the current record number
  1595.    endif
  1596.  
  1597.    if .not. lIsDeleted        && was record 'deleted' before?
  1598.       recall                  && if not, undelete it ... (turn flag off)
  1599.    endif 
  1600.  
  1601. RETURN (lIsUnique)
  1602. *-- EoF: IsUnique()
  1603.  
  1604. *===============================================================================
  1605. * MISC ROUTINES -- Ones that don't fit into other categories, quite ... but
  1606. * are none-the-less very useful ... many of these routines have been placed
  1607. * in the library file:  MISC.PRG.
  1608. *===============================================================================
  1609.  
  1610. PROCEDURE SetPrint
  1611. *-------------------------------------------------------------------------------
  1612. *-- Programmer..: Ken Mayer (KENMAYER)
  1613. *-- Date........: 05/24/1991
  1614. *-- Notes.......: Used to set the the appropriate default settings. 
  1615. *--               (Can be modified easily for other printers ...)
  1616. *--               If you want "letter quality" print on some printers,
  1617. *--               you can take the * out from the one line below. Note
  1618. *--               that some printer drivers don't have a "letter quality" mode,
  1619. *--               and dBASE will spit out an error message if you try to
  1620. *--               force it (by using _pquality). I use this routine for
  1621. *--               various systems, and only use _pquality for my dot matrix
  1622. *--               at home. Change the printer driver below to the one you
  1623. *--               are using. The _pdriver line only REALLY needs to be 
  1624. *--               in use on a LAN, where who knows what settings may have been
  1625. *--               dumped into the printer in between the time you loaded dBASE
  1626. *--               (and the printer driver) and the time you really want to
  1627. *--               print?
  1628. *-- Written for.: dBASE IV, 1.1
  1629. *-- Rev. History: None
  1630. *-- Calls.......: None
  1631. *-- Called by...: Any
  1632. *-- Usage.......: do setprint
  1633. *-- Example.....: do setprint
  1634. *-- Returns.....: None
  1635. *-- Parameters..: None
  1636. *-------------------------------------------------------------------------------
  1637.     *_pdriver  = "HPLAS2I"  && printer driver
  1638.     _ppitch   = "PICA"     && printer pitch (10 CPI)    
  1639.     _box      = .t.          && make sure we can print boxes/line draw
  1640.     _ploffset = 0          && page offset (left side) to 0
  1641.     _lmargin  = 0          && left margin (also set to 0)
  1642.     _rmargin  = 80         && right margin set to 80
  1643.     _plength  = 66         && page length 
  1644.     _peject   = "NONE"     && don't send extra blank pages . . .
  1645.     * _pquality = .t.        && set print quality to high -- not available
  1646.                              && for some printers (i.e., LaserJets)
  1647.     
  1648. RETURN   
  1649. *-- EoP: SetPrint
  1650.  
  1651. FUNCTION DosRun
  1652. *-------------------------------------------------------------------------------
  1653. *-- Programmer..: Michael P. Dean (Ashton-Tate)
  1654. *-- Date........: 05/01/1992
  1655. *-- Notes.......: A routine to run a DOS program, checks to see if a
  1656. *--               window is active -- if so, it avoids the inevitable
  1657. *--               "Press any key to continue" and the subsequent messing
  1658. *--               up of the screen display.
  1659. *-- Written for.: dBASE IV, 1.1
  1660. *-- Rev. History: Pulled from A-T BBS 
  1661. *--               05/13/1991 - modified by Ken Mayer (KENMAYER) to use the DBASE
  1662. *--               RUN() function, rather than the ! or RUN commands.
  1663. *--               (suggested by Clinton L. Warren (VBCES).)
  1664. *--               Minor additions for screens from "Bosephus" on ATBBS 10/31/91
  1665. *--               12/14/1991 - modified by Jim Magnant (TXAGGIE) to deactivate
  1666. *--               and reactivate up to 10 windows ...
  1667. *--               04/21/1992 -- Modified for dBASE IV, 1.5 to use memory 
  1668. *--               handling parameters (.t.,<command>,.t.) of RUN() function.
  1669. *--               05/01/1992 -- Modified to allow use with EITHER 1.1 or 1.5.
  1670. *--                By calling VERSION() without a parm, the version of dBASE
  1671. *--                or RUNTIME is the last three characters on the right. 
  1672. *--                Taking the VAL() of that, we can ask if the version is => 1.5
  1673. *--                and process from there.
  1674. *-- Calls.......: None
  1675. *-- Called by...: Any
  1676. *-- Usage.......: DosRun(<cCmd>)
  1677. *-- Example.....: ndummy = dosrun("DIR /W /P")
  1678. *--                 * or
  1679. *--               ndummy = dosrun(memvar)  && where memvar contains dos
  1680. *--                                        && command and parameters ...
  1681. *-- Returns.....: Nul
  1682. *-- Parameters..: cCmd = Command (and parameters) to be executed
  1683. *-------------------------------------------------------------------------------
  1684.  
  1685.     parameter cCmd
  1686.     private aWindow, n, nRun
  1687.     
  1688.     save screen to sDOS          && save screen ...
  1689.     n = 0                        && set to 0 in case there are NO Windows active
  1690.     declare aWindow[10]
  1691.     aWindow[1] = window()               && grab window name of current window
  1692.     if len(trim(aWindow[1])) > 0        && if there's a window, deactivate
  1693.         n = 1 
  1694.         do while len(trim(aWindow[n])) > 0  && if there are more windows ...
  1695.             deactivate window &aWindow[n]    && deactivate them, too ...
  1696.             n = n + 1
  1697.             aWindow[n] = window()
  1698.         enddo
  1699.     endif
  1700.     set console off                     && don't display to screen
  1701.     if val(right(version(),3)) => 1.5   && check version number. If > 1.5
  1702.         nRun = run(.t.,"&cCmd",.t.)      &&  use complete swapping of dBASE, etc.
  1703.     else                                && else it's 1.1 or 1.0
  1704.         nRun = run("&cCmd")              &&  use older version of RUN() function
  1705.     endif
  1706.     set console on                      && ok, display to screen
  1707.     n = n - 1                           && compensate for final n=n+1 in prev.
  1708.     if len(trim(aWindow[1])) > 1        && if there's a window, reactivate
  1709.        do while n > 0                   && all but last window
  1710.             activate window &aWindow[n]   && activate
  1711.             n = n - 1                     && decrement stack
  1712.         enddo
  1713.         activate window &aWindow[1]      && activate final window ...
  1714.     endif
  1715.     restore screen from sDOS
  1716.     release screen sDOS
  1717.     
  1718. RETURN ""
  1719. *-- EoF: DosRun()
  1720.  
  1721. FUNCTION ScrnRpt
  1722. *-------------------------------------------------------------------------------
  1723. *-- Programmer...: Bryan Flynn (AT/BOR-BBS)
  1724. *-- Date.........: 10/31/91
  1725. *-- Notes........: Used to display a dBASE Report on screen, allowing pauses
  1726. *--                when the screen is full.
  1727. *-- Written for..: dBASE IV, 1.1
  1728. *-- Rev. History.: Changed by a lot of people to current version.
  1729. *-- Calls........: Any
  1730. *-- Called by....: Any
  1731. *-- Usage........: ?ScrnRpt("<cRpt cArg>")
  1732. *-- Example......: ?ScrnRpt("FT_REP1 FOR PROB='HPEQUIP'")
  1733. *-- Returns......: ""  (Nul)
  1734. *-- Parameters...: cRpt  = Name of report with any arguments for command line
  1735. *-------------------------------------------------------------------------------
  1736.  
  1737.     Parameter cRpt
  1738.     private lPWait, nPLength, cEscape
  1739.     
  1740.     *-- save system variables
  1741.    lPWait   = _pwait
  1742.    nPLength = _plength
  1743.     cEscape  = SET("ESCAPE")
  1744.     *-- set new variables
  1745.    _pwait   = .t.
  1746.     _plength = iif("43" $ SET("DISPLAY"),40,25)  && if EGA43, set to 40, else 25
  1747.    set escape on
  1748.     
  1749.     *-- store current screen
  1750.    save screen to sTemp
  1751.    clear
  1752.  
  1753.     *-- set printer to nowhere and generate report
  1754.    set printer to nul
  1755.    report form &cRpt noeject to print
  1756.  
  1757.     *-- set things back to normal
  1758.    set escape &cEscape
  1759.    set printer to LPT1
  1760.    wait
  1761.    clear
  1762.    restore screen from sTemp
  1763.    release screen sTemp
  1764.    _pwait   = lPWait
  1765.    _plength = nPLength
  1766.  
  1767. RETURN ""
  1768. *-- EoF: ScrnRpt()
  1769.  
  1770. FUNCTION IsMouse
  1771. *-------------------------------------------------------------------------------
  1772. *-- Programmer..: Ken Mayer (KENMAYER)
  1773. *-- Date........: 06/18/1992
  1774. *-- Notes.......: This is used to determine the presence of a mouse driver.
  1775. *--               Returns a .t. if a mouse driver is detected, a .f. otherwise.
  1776. *--               This routine will turn the mouse off, automatically. This
  1777. *--               can be used to detect a mouse, and turn it off, as well
  1778. *--               as to set a memvar to determine the current mouse state.
  1779. *--               For example, after running this routine, the mouse will be
  1780. *--               off (if there's a driver).
  1781. *--               ******************************
  1782. *--               **** REQUIRES JPMOUSE.BIN ****
  1783. *--               ******************************
  1784. *-- Written for.: dBASE IV, 1.5
  1785. *-- Rev. History: None
  1786. *-- Calls.......: None
  1787. *-- Called by...: Any
  1788. *-- Usage.......: IsMouse()
  1789. *-- Example.....: ?IsMouse()
  1790. *-- Returns.....: Logical
  1791. *-- Parameters..: None
  1792. *-------------------------------------------------------------------------------
  1793.  
  1794.     private cRetVal, lIsMouse, X
  1795.     
  1796.     Load JPMOUSE.BIN
  1797.     cRetVal = call("JPMOUSE","?")
  1798.     lIsMouse = iif(cRetVal="T",.t.,.f.)
  1799.     if lIsMouse
  1800.         x = call("JPMOUSE","H")
  1801.     endif
  1802.     release module JPMOUSE
  1803.  
  1804. RETURN lIsMouse
  1805. *-- EoF: IsMouse()
  1806.  
  1807. PROCEDURE SetMouse
  1808. *-------------------------------------------------------------------------------
  1809. *-- Programmer..: Ken Mayer (KENMAYER)
  1810. *-- Date........: 06/18/1992
  1811. *-- Notes.......: This is used to determine the presence of a mouse driver,
  1812. *--               and/or turn the mouse cursor off in dBASE IV, 1.5
  1813. *--               ******************************
  1814. *--               **** Requires JPMOUSE.BIN ****
  1815. *--               ******************************
  1816. *-- Written for.: dBASE IV, 1.5
  1817. *-- Rev. History: None
  1818. *-- Calls.......: None
  1819. *-- Called by...: Any
  1820. *-- Usage.......: Do SetMouse with <c_Mouse>
  1821. *-- Example.....: PUBLIC c_Mouse
  1822. *--               x=ismouse()  && function in MISC.PRG
  1823. *--               store "OFF" to c_Mouse  && after calling IsMouse() it's 'Off'
  1824. *--               ON KEY LABEL Alt-M DO SetMouse
  1825. *-- Returns.....: .T.
  1826. *-- Parameters..: c_Mouse = A GLOBAL memory variable -- this can/will be changed
  1827. *--                         by this procedure to the opposite scenario when the
  1828. *--                         routine is called. The concept here is to switch
  1829. *--                         the mouse on and/or off if there's a mouse driver.
  1830. *--                This memvar should be set to the current status of the mouse-
  1831. *--                if on, it should hold "ON" in it ...
  1832. *-------------------------------------------------------------------------------
  1833.  
  1834.     private X
  1835.     
  1836.     if type("C_MOUSE") # "C"         && if c_Mouse has not been defined as
  1837.         return                        &&   a character field, return
  1838.     endif
  1839.     
  1840.     load JPMOUSE.BIN                && load the module
  1841.     
  1842.     *-- if the mouse is off, we're going to set it on ("S"), if on, we're
  1843.     *-- going to set it off "H")
  1844.     cSetMouse = iif(upper(c_Mouse) = "OFF","S","H") 
  1845.     x=call("JPMOUSE",cSetMouse)      
  1846.     
  1847.     release module JPMOUSE           && remove from memory
  1848.     
  1849.     *-- if c_Mouse was 'off' we are setting it 'on', and vice versa
  1850.     c_Mouse = iif(upper(c_Mouse) = "OFF","ON","OFF") && change state of c_Mouse
  1851.  
  1852. RETURN
  1853. *-- EoP: SetMouse
  1854.  
  1855. FUNCTION SwitchLib
  1856. *-------------------------------------------------------------------------------
  1857. *-- Programmer..: Ken Mayer (KENMAYER)
  1858. *-- Date........: 05/01/1992
  1859. *-- Notes.......: Used with dBASE IV, 1.5 to switch LIBRARY files. It's designed
  1860. *--               as a quick toggle between libraries. See example below.
  1861. *-- Written for.: dBASE IV, 1.5
  1862. *-- Rev. History: None
  1863. *-- Calls.......: None
  1864. *-- Called by...: Any
  1865. *-- Usage.......: SwitchLib(<cNewLib>)
  1866. *-- Example.....: cOldLib = SwitchLib("FILES")
  1867. *--               *-- execute function/procedure needed
  1868. *--               cOldLib = SwitchLib("&cOldLib")
  1869. *-- Returns.....: Old Library setting
  1870. *-- Parameters..: cNewLib = Library file you wish to change to. If the file
  1871. *--                         extension is not '.PRG', you should add the file
  1872. *--                         extension to the description (I.e, "FILES.LIB")
  1873. *-------------------------------------------------------------------------------
  1874.     
  1875.     parameters cNewLib
  1876.     private cCurLib
  1877.     
  1878.     cCurLib = library()
  1879.     set library to &cNewLib
  1880.     
  1881. RETURN cCurLib
  1882. *-- EoF: SwitchLib()
  1883.  
  1884. FUNCTION VerLevel
  1885. *-------------------------------------------------------------------------------
  1886. *-- Programmer..: Bowen Moursund
  1887. *-- Date........: 06-24-1992
  1888. *-- Notes.......: Returns the numeric version number of the current version
  1889. *--               of dBASE or RUNTIME. Useful in version specific routines.
  1890. *-- Written for.: dBASE IV, 1.5
  1891. *-- Rev. History: None
  1892. *-- Calls.......: None
  1893. *-- Called by...: Any
  1894. *-- Usage.......: VerLevel()
  1895. *-- Example.....: if VerLevel() >= 1.5
  1896. *-- Returns.....: a numeric equivalent of Version()
  1897. *-- Parameters..: None
  1898. *-------------------------------------------------------------------------------
  1899.  
  1900.     private cVersion, nPos
  1901.     cVersion = version()
  1902.     nPos = 1
  1903.     do while left(right(cVersion,nPos),1) # " "
  1904.         nPos = nPos + 1
  1905.     enddo
  1906.  
  1907. RETURN val(right(cVersion,nPos+1))
  1908. *-- Eof() VerLevel
  1909.  
  1910. *===============================================================================
  1911. *-- End of Procedure File -- PROC.PRG
  1912. *===============================================================================
  1913.